home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual BASIC 5.0 (Ent. Edition) / Vb5ent Extractor.EXE / VB / SAMPLES / PGUIDE / PROGWOB / PWORECT.CLS < prev    next >
Encoding:
Visual Basic class definition  |  1996-11-26  |  6.8 KB  |  233 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "Rectangle"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11. ' >> Best viewed in Full Module view. <<
  12. '
  13. ' Storage for debug ID number.
  14. Private mlngDebugID As Long
  15. Implements IDebug
  16.  
  17. ' The Rectangle implements two interfaces;
  18. '   it also has one property (Filled) and
  19. '   one method (TimeTest) on its own
  20. '   interface.
  21.  
  22. Implements IShape
  23. Implements Polygon
  24.  
  25. ' The inner Polygon object actually holds
  26. '   the data and does some of the work.
  27. '   The Rectangle keeps references to both
  28. '   the Polygon interface and the IShape
  29. '   interface of the inner Polygon.
  30. Private mpyg As Polygon
  31. Private mish As IShape
  32.  
  33. ' Storage for Color property (Polygon
  34. '   interface implementation).
  35. Private mrgbColor As Long
  36.  
  37. ' Storage for the Filled property (on the
  38. '   Rectangle object's default interface).
  39. Private mblnFilled As Boolean
  40.  
  41. ' -------------------------------------
  42. ' This is the beginning of Rectangle's
  43. '   implementation of the IShape
  44. '   interface.
  45.  
  46. ' IShape.DrawToPictureBox is called to
  47. ' ------ ----------------   draw a shape,
  48. '   so each class of shape must supply
  49. '   its own implementation.
  50. '
  51. Private Sub IShape_DrawToPictureBox(ByVal pb As PictureBox)
  52.     ' Instead of delegating to the IShape
  53.     '   interface of the inner Polygon, the
  54.     '   Rectangle takes advantage of the
  55.     '   fact that there's a graphics command
  56.     '   to draw a box in one operation
  57.     '   instead of four (graphics being
  58.     '   presumably the most time-consuming
  59.     '   kind of operation).
  60.     Dim sngX1 As Single, sngY1 As Single
  61.     Dim sngX2 As Single, sngY2 As Single
  62.     Call mpyg.GetPoint(0, sngX1, sngY1)
  63.     Call mpyg.GetPoint(1, sngX2, sngY2)
  64.     If mblnFilled Then
  65.         pb.Line (sngX1, sngY1)-(sngX2, sngY2), mrgbColor, BF
  66.     Else
  67.         pb.Line (sngX1, sngY1)-(sngX2, sngY2), mrgbColor, B
  68.     End If
  69. End Sub
  70.  
  71. ' IShape.TimeTest method is used to show
  72. ' ====== --------       the reduced call
  73. '   overhead of a method called on an
  74. '   interface that several classes
  75. '   implement -- as opposed to calling
  76. '   a similar method on the classes'
  77. '   default interfaces.
  78. '
  79. Private Sub IShape_TimeTest()
  80. End Sub
  81.  
  82. ' -------------------------------------
  83. ' This is the beginning of the implementation
  84. '   of the Polygon interface.
  85.  
  86. ' Polygon.Color - Because the inner
  87. ' ======= -----     Polygon isn't used
  88. '   for drawing the Rectangle, the Color
  89. '   property is completely overridden.
  90. '   This is not required; the Rectangle
  91. '   could delegate storage of the Color
  92. '   property to the inner Polygon (as
  93. '   the Triangle class does), saving
  94. '   the implementation code and storage
  95. '   space.  The color could then be
  96. '   retrieved from the inner Polygon
  97. '   when drawing is done.
  98. Private Property Get Polygon_Color() As Long
  99.     Polygon_Color = mrgbColor
  100. End Property
  101. '
  102. Private Property Let Polygon_Color(ByVal RHS As Long)
  103.     If 0 <> (RHS And &HFF000000) Then
  104.         Err.Raise vbObjectError + 2080, , _
  105.             "Invalid color value for Polygon."
  106.         Exit Property
  107.     End If
  108.     mrgbColor = RHS
  109. End Property
  110.  
  111. ' Polygon.TimeTest - Rectangle has three
  112. ' ======= --------  TimeTest methods, one
  113. '   on the IShape interface (used to show
  114. '   polymorphism and early binding), one on
  115. '   its own interface (used to show late
  116. '   binding), and this one.  This one is
  117. '   a side effect of the fact that Rectangle
  118. '   implements the Polygon interface; it's
  119. '   not used for anything.
  120. Private Sub Polygon_TimeTest()
  121. End Sub
  122.  
  123. ' Polygon.GetPoint
  124. ' ======= --------
  125. '
  126. Private Sub Polygon_GetPoint(ByVal intPoint As Integer, X As Single, Y As Single)
  127.     ' Delegate to the inner Polygon.
  128.     Call mpyg.GetPoint(intPoint, X, Y)
  129. End Sub
  130.  
  131. ' Polygon.GetPointCount
  132. ' ======= -------------
  133. '
  134. Private Property Get Polygon_GetPointCount() As Integer
  135.     ' There's no point in delegating to
  136.     '   the inner Polygon, because the
  137.     '   Rectangle is always specified by
  138.     '   just two points.
  139.     Polygon_GetPointCount = 2
  140. End Property
  141.  
  142. ' Polygon.SetPoints - When implementing the
  143. ' ======= ---------     SetPoints method
  144. '   of the Polygon interface, the Rectangle
  145. '   executes its own code to verify that
  146. '   the input array contains only two
  147. '   points (four Singles), and then
  148. '   delegates to the inner Polygon
  149. '   object.
  150. Private Sub Polygon_SetPoints(asngPoints() As Single)
  151.     Dim blnBadArray As Boolean
  152.     On Error Resume Next
  153.     ' Ensure that the input array contains
  154.     '   no more than four points.  (The
  155.     '   Polygon's SetPoint method will
  156.     '   verify that the array is zero-
  157.     '   based.)
  158.     If UBound(asngPoints) <> 3 Then blnBadArray = True
  159.     ' If an error occurred calling UBound,
  160.     '   reject the array.
  161.     If Err.Number <> 0 Then blnBadArray = True
  162.     If blnBadArray Then
  163.         Err.Raise vbObjectError + 2083, , _
  164.             "A rectangle is specified by an array of four numbers (left, top, right, bottom) in a zero-based array."
  165.         Exit Sub
  166.     End If
  167.     ' Delegate to the inner Polygon, which
  168.     '   completes validation of the array
  169.     '   and stores it.
  170.     Call mpyg.SetPoints(asngPoints)
  171. End Sub
  172.  
  173. ' --------------------------------------
  174. ' This is the beginning of the Rectangle
  175. '   object's own (default) interface.
  176.  
  177. ' TimeTest method takes no
  178. ' --------   arguments, and
  179. '   immediately returns.  It's used to
  180. '   illustrate late binding, as opposed
  181. '   to the early binding provided by
  182. '   calling TimeTest on the IShape
  183. '   interface.
  184. Public Sub TimeTest()
  185. End Sub
  186.  
  187. ' Filled property determines whether a
  188. ' ------    rectangle is filled when
  189. '   drawn.
  190. Public Property Get Filled() As Boolean
  191.     Filled = mblnFilled
  192. End Property
  193. '
  194. Public Property Let Filled(ByVal NewValue As Boolean)
  195.     mblnFilled = NewValue
  196. End Property
  197.  
  198. ' --------------------------------------
  199. ' This is the beginning of the class's
  200. '   private procedures (helper procedures
  201. '   and event procedures).
  202.  
  203. Private Sub Class_Initialize()
  204.     Dim asngPoints(0 To 3) As Single
  205.     ' Debug code.
  206.     mlngDebugID = DebugInit(Me)
  207.     '
  208.     ' Create the inner Polygon object, and
  209.     '   get a reference to its IShape
  210.     '   interface.
  211.     Set mpyg = New Polygon
  212.     Set mish = mpyg
  213.     ' Initialize the inner Polygon.
  214.     Call mpyg.SetPoints(asngPoints)
  215. End Sub
  216.  
  217. Private Sub Class_Terminate()
  218.     DebugTerm Me
  219. End Sub
  220.  
  221. ' -------- IDebug Implementation --------
  222. '
  223. ' IDebug.DebugID gives you a way to tell
  224. ' ====== -------    objects apart.  It's
  225. '   required by the DebugInit, DebugTerm,
  226. '   and DebugShow debugging procedures
  227. '   declared in modFriend.
  228. '
  229. Private Property Get IDebug_DebugID() As Long
  230.     IDebug_DebugID = mlngDebugID
  231. End Property
  232.  
  233.